perm filename MFOUT.SAI[MF,DEK]14 blob
sn#588817 filedate 1981-05-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 entry begin comment The output module of METAFONT.
C00009 00003 Routines for time of day and file information (highly system-dependent)
C00015 00004 openofil
C00025 00005 special stuff for byte-oriented output
C00029 00006 Routines for proof mode.
C00049 00007 Routines for chr mode.
C00055 00008 Routines for fnt mode.
C00061 00009 Routines for .oc files and .wd files
C00062 00010 Routines for tfm mode.
C00075 00011 Routines for Alphatype fonts
C00084 00012 internal procedure initout # get MFOUT started properly
C00092 00013 Stuff for extended memory
C00098 ENDMK
C⊗;
entry; begin comment The output module of METAFONT.
(It is wise to read MFSYS and the raster formats explained in MFRAST
before going very deeply into the following code.)
Each output module is intended to handle a set of output devices and modes at some
particular installation. The following procedures are required:
initout gets the output module started initially
finishchar called when a character has been fully specified
closeout finishes the output
entersym when a symbol has become "known" in proof mode
clearchar initialize for a new character
The module MFOUT can handle output of various forms, depending upon the
settings of compile-time switches. Proof output goes either to a Press
file (PRESS) or the the Xerox Graphics Printer (XGP). If DOVERMODES
is true, then two additional output modes are enabled: ocmode and
dotwdmode (not wdmode since this looks like a w-variable!);
comment Certain bits of the "control" variable govern output modes supported:
'1000 proof mode
'2000 chr file mode
'4000 make TEX font metric (.tfm) file
'10000 make xgp font (.fnt)
'20000 make Alphatype CRS font (only works on WAITS, for security)
'400000 label the points in proof mode (either flavor)
'4000000 make arrow for illustration file in PRESS proof mode
'10000000 illustration file in PRESS proof mode to be color separated
IFDOVERMODES
'20000000 make Dover .OC font
'40000000 make PrePress-style widths (.WD) file
'100000000 use charwx and charwy to get vector style widths
ENDDOVERMODES;
comment Certain bits of the "control" variable govern the on-line output:
'1000000 display each character after it has been fully drawn
;
require "MFHDR.SAI" source_file;
internaldef symbolic=⊂(control land '1000)⊃ # keep list of "known" xy-variables;
internaldef tfmmode=⊂(control land '4000)⊃, crsmode=⊂(control land '20000)⊃;
internaldef needchecksum=⊂(control land '24000)⊃;
define proofmode=⊂(control land '1000)⊃, chrmode=⊂(control land '2000)⊃,
fntmode=⊂(control land '10000)⊃;
IFDOVERMODES
define ocmode=⊂(control land '20000000)⊃, wdmode=⊂(control land '40000000)⊃;
define vectorwidths=⊂(control land '100000000)⊃;
ENDDOVERMODES
define points=⊂(control land '400000)⊃;
define chardisplay=⊂(control land '1000000)⊃;
IFPRESS
define arrow=⊂(control land '4000000)⊃,
color=⊂(control land '10000000)⊃;
ENDPRESS
internaldef brksize=10 # the number of distinct breaks per character;
internal saf integer array brktab[0:1,0:brksize+1] # breaks in increasing order;
internal saf integer array brkptr[0:1] # current number of entries in brktab;
preload_with 0,1,2,27,3,24,28,33,4,17,25,31,29,12,34,14,5,8,18,36,26,23,32,16,
30,11,13,7,35,22,15,10,6,21,9,20,19;
internal saf integer array bit_id[0:36] # used to identify bits;
comment The following proc uses the bit_id array to compute the index of the
rightmost one-bit in a word, where the bit indices run from
zero to (bitsperwd-1), left to right. (If x=0 on input, then
bitsperwd is returned). The if test is needed to
prevent an arithmetic overflow in the case that x is the most
negative reresentable number (in which case -x is not representable);
simp integer procedure rightmostbitindex(integer x);
begin integer signbit,z;
signbit←1 lsh (bitsperwd-1);
if x=signbit then return(0);
z←x land (lnot signbit) # avoid negative dividend;
return(bitsperwd - bit_id[(z land (-z)) mod 37]);
end;
comment Routines for time of day and file information (highly system-dependent);
integer octaltime # the machine's one word date/time stamp, in whatever
format the OS specifies (set by initout);
IFWAITS
comment These routines are due to Hans Moravec;
string procedure daytime;
begin comment returns octaltime down to the second, as a string;
integer d,t,sw,sd; string s;
string procedure cvs2(integer i);
return((((i div 10) mod 10)+"0")&((i mod 10)+"0"));
t←octaltime land '777777; d←octaltime lsh -18;
getformat(sw,sd); setformat(0,7);
s←cvs((d mod 31)+1)&", "&cvs((d div 31)div 12 + 1964);
setformat(sw,sd);
return((case ((d div 31) mod 12) of
("January","February","March","April","May","June",
"July","August","September","October","November","December"))&" "&
s&" "&cvs2(t div (60*60))&":"&
cvs2((t div 60) mod 60)&":"&cvs2(t mod 60));
end;
string procedure filinf(integer channel);
begin comment returns file name, extension, and area of the file open on channel;
define POPJ(A,B)=⊂'263000000000 lor (A lsh 23) lor B⊃;
define MTAPE(A,B)=⊂'072000000000 lor (A lsh 23) lor B⊃;
saf integer array mtp[0:3], ret[0:6], cod[0:2];
string fn,ext,ppn,t; integer i;
mtp[0]←cvsix("GODMOD"); mtp[1]←'14; mtp[2]←(-5 lsh 18) lor location(ret[0]);
cod[0]←MTAPE(channel,location(mtp[0])); cod[1]←cod[2]←POPJ('17,0);
START_CODE PUSHJ '17,ACCESS(COD[0]); END;
fn←cvxstr(ret[1]); while length(fn)>0 ∧ fn[∞ to ∞]=" " DO fn←fn[1 to ∞-1];
ext←cvxstr(ret[2] land '777777000000);
while length(ext)>0 ∧ ext[∞ to ∞]=" " do ext←ext[1 to ∞-1];
ppn←cvxstr(ret[4]); t←ppn[1 to 3]&","&ppn[4 to 6];
ppn←""; for i←1 thru 7 do if t[i to i]≠" " then ppn←ppn&t[i to i];
return(fn&"."&ext&"["&ppn&"]");
end;
IFPRESS
integer procedure altotime;
comment Returns the number of seconds since midnight, Jan. 1, 1901 GMT;
begin integer stdtime # seconds since midnight, Pacific standard time;
integer days # days since Jan. 1, 1964;
stdtime←call(0,"STDTIM") land '777777;
days←call(0,"DAYCNT");
return(((23010+days)*24+8)*3600+stdtime);
end;
string procedure username;
comment Returns the name of the logged-in user as a SAIL string;
begin string prg, uname, nxtprg, nxtnam;
integer namfil, brchar, eof, lftabbreak, ppn, i, j;
ppn←call(0,"GETPPN") # ppn is in 6-bit format;
prg←"" # null characters in prg would hurt, so can't use CVXSTR;
for i←-12 step 6 until 0 do if (j←(ppn lsh i) land '77) then prg←prg&(j+'40);
setbreak(lftabbreak←getbreak,'12&'11,'15&'15,"ISN");
open(namfil←getchan,"DSK",0,2,0,150,brchar,eof);
lookup(namfil,"FACT.TXT[SPL,SYS]", eof);
uname←"("&prg&" @ SAIL)" # this is used for new accounts not yet in the FACT file;
brchar←'12; comment we don't need to check brchar below if FACT is good;
while not eof do
begin if brchar='12 then nxtprg←input(namfil,lftabbreak);
if brchar='11 then nxtnam←input(namfil,lftabbreak);
if equ(prg,nxtprg) then
begin uname←nxtnam&" "&uname; done;
end;
end;
release(namfil);
relbreak(lftabbreak);
return(uname);
end;
ENDPRESS
ENDWAITS
IFC TENEX OR TOPS20 THENC
string procedure daytime # translate octaltime into a string;
begin return(odtim(octaltime,'036000000000)) end;
string procedure filinf(integer channel);
begin return(jfns(channel,0)) end;
IFPRESS
integer procedure altotime # translate octaltime into a Alto-format time;
begin
return(((octaltime lsh -18)-15385)*(3600*24)+(octaltime land '777777));
end;
string procedure username;
begin integer logdir,condir,ttyno;
gjinf(logdir,condir,ttyno);
return(dirst(logdir));
end;
ENDPRESS
ENDC
comment openofil;
internal string maintitle # symbolic description of the font being generated;
internal string ofilname # output file name, set by first input;
string timeofday # time to be used on output;
integer checksum # unique ID computed from .tfm data, put into output fonts;
internaldef numberofmodes=5;
internaldef tfm=1,proof=2,xgpfnt=3,chrs=4,alf=5;
IFDOVERMODES
internaldef numberofmodes=7;
internaldef doveroc=6,presswd=7;
ENDDOVERMODES
saf integer array ochan[1:numberofmodes] # channels for output;
saf string array ofilext[1:numberofmodes] # file name extensions;
saf string array flname[1:numberofmodes] # actual file names opened;
integer prfpno # page number in proof mode;
string prfheader # time of day and filename for proof mode;
IFPRESS
integer greyhue, edgehue, dothue, curhue # hues in color mode;
integer recnum # number of current Press record;
integer partdirbufptr # addr of Press part directory buffer (wherever it is);
integer pdptr # byte pointer into Press part directory buffer;
integer nparts # number of Press parts;
ENDPRESS
internal integer fntptr # words output in fntmode or subglyphs output in crsmode;
internal saf integer array fntdir[0:'377] # directory blocks of font file;
comment The fntdir array is used to hold font-wide header information
for both xgpfnt and alf output. Hence, you can't produce both outputs at
the same time. This explains the errorstops with "Incompatible
resolution" that occur in the procedure openofil;
IFDOVERMODES
define nonexistentcharflag=⊂-(2.0↑120)⊃ # a real number that won't occur
as the vector width X component of any real character;
saf real array CharWidthX[0:'177];
saf real array CharWidthY[0:'177] # x and y components of
the vector widths of characters;
integer bbxlmin, bbxrmax, bbylmin, bbyhmax # extremes of bounding box;
real charwxmax, charwxmin, charwymax, charwymin # extremes of width vector
components;
define IX(typ, lngth)=⊂((typ lsh 12)+lngth)⊃;
saf integer array charsegptr[0:'177] # filepos's of individual char segments;
define charsegfilepos=⊂('3000)⊃ # earliest filepos in .oc file that a
character segment can start (in 16-bit words), rounded up to the
nearest multiple of 2*pagesize(!);
ENDDOVERMODES
integer array nextword,bytecount[1:numberofmodes];
define out32(chan,bits)=⊂wordout(chan,(bits) lsh (bitsperwd-32))⊃;
integer procedure openofil(integer t) # initializes output for mode t;
begin comment This procedure is called when output for mode t is requested.
It opens the file and gets things started and returns the channel number;
integer i # loop index;
string fn # output file name;
boolean binarymode # true if 36-bit-bytes, false if text chars;
if ochan[t]≥0 then return(ochan[t]);
binarymode←(t≠chrs) # chrs mode is always text, others usually binary;
IFXGP
if t=proof then binarymode←false # proof is text for XGP, binary for Press;
ENDXGP
open(ochan[t]←getchan,"DSK",if binarymode then 8 else 0,0,2,0,0,eof);
if not ofilname then ofilname←"mfput";
fn←ofilname&ofilext[t];
loop begin enter(ochan[t],fn,eof);
if eof then
begin print(nextline,"I can't write on file ",fn,
nextline,"Output file = ");
fn←inchwl;
end
else done;
end;
flname[t]←fn;
case t of begin
IFDOVERMODES
[presswd] begin
arrclr(CharWidthX,nonexistentcharflag) # mark all characters as missing;
bbxlmin←infty; bbxrmax←-infty;
bbylmin←infty; bbyhmax←-infty;
charwxmin←infty; charwxmax←-infty;
charwymin←infty; charwymax←-infty;
end;
[doveroc] begin
for i←1 thru charsegfilepos div 2 do wordout(ochan[doveroc],0);
bytecount[doveroc]←charsegfilepos*2 # start of first character segment;
arrclr(charsegptr,-1) # mark all characters as missing;
end;
ENDDOVERMODES
[xgpfnt] begin string longtitle;
if ochan[alf]≥0 then
errorstop("Incompatible resolution") # see comment at decl of fntdir array;
for i←0 thru '237 do fntdir[i]←0;
longtitle←maintitle&(nextline&"Written by METAFONT, ")&timeofday;
for i←'240 thru '377 do fntdir[i]←cvasc(longtitle[5*(i-'237)-4 for 5]);
arryout(ochan[xgpfnt],fntdir[0],'400) # will be overwritten later;
fntptr←'400; fntdir['203]←maxht end;
[chrs] out(ochan[chrs],maintitle&(nextline&"Based on .CHR file written by METAFONT, ")&
timeofday&(nextline&"⊗"&nextline)) # font description page;
[proof] begin
prfpno←0;
prfheader←timeofday&" "&filinf(ochan[proof])&" Page ";
IFXGP
out(ochan[proof],"/LMAR=50/TMAR=50/RMAR=1700/BMAR=1/PMAR=0/XLINE=0"&
"/FONT#0=NGR13/FONT#1=FIG/END") # preamble for xgp server;
ENDXGP
IFPRESS
recnum←0; nparts←0;
pdptr←point(16,memory[partdirbufptr],-1);
greyhue←edgehue←dothue←0 # default if color turned on later;
if color then
begin
integer procedure gethue(string prompt);
begin string s; integer acc;
outstr("Enter hue for "&prompt&":"); s←inchwl;
acc←0;
while (s≥"0") and (s≤"9") do acc←10*acc+lop(s)-"0";
return(acc);
end;
greyhue←gethue("internal pixels (R=0,Y=40,G=80,C=120,B=160,M=200)");
edgehue←gethue("boundary pixels");
dothue←gethue("data points");
end;
ENDPRESS
end;
[alf] begin string s;
if ochan[xgpfnt]≥0 then
errorstop("Incompatible resolution") # see comment at decl of fntdir array;
for i←0 thru '377 do fntdir[i]←0;
s←ofilname; antid←0; while s do antid←314159*antid+lop(s);
antid←antid lor (1 lsh 31) # this is an identification number depending on fontname;
out32(ochan[t],antid);
alfptr←1 end;
else comment do nothing;
end;
return(ochan[t]);
end;
comment special stuff for byte-oriented output;
comment Here are some procedures for doing byte-oriented output.
SAIL's normal "wordout" is doing the real work. The arrays
nextword holds the bytes that will go into making a new
output word as they accumulate. The array bytecount keeps
track of the total number of bytes output to each file;
comment integer array nextword,bytecount[1:numberofmodes];
simp procedure Bout(integer mode, byte);
begin comment output an 8-bit byte to channel for mode;
integer cnt,nxtwd,ofst;
cnt←bytecount[mode];
case (cnt mod 4) of
begin
[0] nextword[mode]←byte lsh 28;
[1] nextword[mode]←
nextword[mode] lor ((byte land '377) lsh 20);
[2] nextword[mode]←
nextword[mode] lor ((byte land '377) lsh 12);
[3] wordout(ochan[mode],
nextword[mode] lor ((byte land '377) lsh 4));
else confusion
end;
bytecount[mode]←cnt+1;
end;
simp procedure Wout(integer mode,word);
begin comment output a 16-bit word to channel for mode;
integer cnt,nxtwd,ofst;
cnt←bytecount[mode];
case (cnt mod 4) of
begin
[0] nextword[mode]←word lsh 20;
[2] wordout(ochan[mode],
nextword[mode] lor ((word land '177777) lsh 4));
else confusion comment must be at 16-bit-word boundary;
end;
bytecount[mode]←cnt+2;
end;
simp procedure Dout(integer mode,word);
begin
Wout(mode,word lsh -16); Wout(mode, word);
end;
simp procedure DoutAligned(integer mode,word);
begin
integer cnt;
cnt←bytecount[mode];
if (cnt mod 4)≠0 then confusion;
wordout(ochan[mode],word);
bytecount[mode]←cnt+4;
end;
simp procedure Sout(integer mode, ptr, numbytes);
begin comment output a string of 8-bit bytes: the output file
must start out 32-bit-word aligned!;
integer i, numwords, rembytes;
if bytecount[mode] mod 4≠0 then confusion;
numwords←numbytes div 4;
rembytes←numbytes mod 4;
arryout(ochan[mode],memory[ptr],numwords);
nextword[mode]←memory[ptr+numwords] land (-1 lsh (bitsperwd-8*rembytes));
bytecount[mode]←bytecount[mode]+numbytes;
end;
simp procedure BCPLout(integer mode; string s; integer maxbytes);
begin
integer len, i;
len←(maxbytes-1) min length(s);
Bout(mode,len);
for i←1 thru maxbytes-1 do
if i<=len then Bout(mode,s[i to i]) else Bout(mode,0);
end;
comment Routines for proof mode.
In proof mode, all of the xy-variables are remembered in a special table
as soon as both coordinates become known. This table is organized as a
doubly threaded binary search tree, ordered by decreasing $y$ coordinate,
and for fixed $y$ by increasing $x$ coordinate (i.e., top to bottom, left to right).
The tree nodes have several fields:
llink[p] left son (if $>p$) or inorder predecessor (if $≤p$)
rlink[p] right son (if $>p$) or inorder successor (if $≤p$)
ycoord[p] $y$ coordinate of the point
xcoord[p] $x$ coordinate of the point
strng[p] symbolic name of the point (to be put into the label box)
xll[p],yll[p] coordinates of lower left corner of point label box
xur[p],yur[p] coordinates of upper right corner of point label box
prevbox[p] pointer to previous point label box, ordered by \\{yll}
Hidden points have strng[p] null.
We have $\\{rlink}[0]=0$ and \\{llink}[0] points to the root of the tree.
The smallest unused node is \\{tptr}. To set the tree empty, one sets
$\\{llink}[0]←0$ and $$\\{tptr}←1$. The fields \\{xll}, \\{yll}, \\{xur}, \\{yur},
and \\{prevbox} are used only when allocating boxes for the point labels, just
before outputting the raster pattern. Actually \\{yur} is not stored in memory,
since $\\{yur}[p]$ always equals $\\{yll}[p]+10$.
;
internaldef proofmemsize=250 # size of proof mode tables;
integer saf array llink,rlink,ycoord,xcoord,xll,yll,xur,prevbox[0:proofmemsize-1];
string saf array strng[0:proofmemsize-1];
integer tptr # end of tree;
integer bxptr # pointer to last point label box (head of the \\{prevbox} list);
internal procedure proofins(integer xco,yco; string s) # inserts into tree;
begin integer q,r # pointer variables;
label moveleft,moveright,insert # go here to move downward in the tree;
label compare # go here to decide where to move next in the tree;
r←0;
moveleft: q←llink[r]; if q≤r then
begin llink[r]←tptr; rlink[tptr]←r; llink[tptr]←q; go to insert;
end;
r←q;
compare: if yco>ycoord[r] then go to moveleft;
if yco<ycoord[r] or xco>xcoord[r] then go to moveright;
if xco<xcoord[r] then go to moveleft;
return # this point duplicates one that's already present;
moveright: q←rlink[r]; if q≤r then
begin rlink[r]←tptr; llink[tptr]←r; rlink[tptr]←q; go to insert;
end;
r←q; go to compare;
insert: ycoord[tptr]←yco; xcoord[tptr]←xco; strng[tptr]←s;
tptr←tptr+1; if tptr≥proofmemsize then overflow(proofmemsize);
end;
IFPRESS require "PRESSO.SAI" source_file; ENDPRESS
IFXGP
procedure makeproof # Outputs the raster in printable form;
begin comment This routine figures out how to label the points, and then
it outputs the raster in a format that is printable with a special font.
The point label locations are computed in the following way: We go through
the points from top to bottom, left to right, and use the first available
position from a list of five choices:
centered above the point
centered to the left of the point
centered to the right of the point
centered below the point
in the right margin below previous entries like this
(The last case always succeeds if the other four fail.) A position is
"available" if the corresponding box containing the symbolic name of the point
does not overlap with any previously placed boxes, and if this box is at least
two units away from every other point, measuring distance along vertical
and horizontal lines (Manhattan style). (The box is one unit away from
the point it corresponds to.)
Output for the XGP server is a sequence of 7-bit character codes of the following
types:
'177&'001&'040&x1&x2, where x1&x2=x is a 14-bit binary number, x<4096
means "move to column x"
c, where c is a letter or digit or "."
means "output character c in the FIG font and advance as many
columns as c's width
'012&'177&'003&y1&y2, where y1&y2=y is a 14-bit binary number
means "move to row y (numbered from the top, increasing downwards)
'015&'014&'177&'006&'001
means "cut the paper at the current row (and select FIG font)"
;
simple string procedure twobytes(integer x) # changes x into x1&x2, a 14-bit code
that represents 4x;
begin integer four_x; four_x←4*x; return((four_x lsh -7)&four_x);
end;
define movetocol(x)=⊂begin out(ch,'177&'001&'040);out(ch,twobytes(x-xl+50)) end⊃;
define movetorow(y)=⊂begin out(ch,'012&'177&'003);
out(ch,twobytes(yhigh-(y)+50)) end⊃;
define cutpage=⊂('051&'014&'177&'006&'001)⊃;
integer xl,xr,p,q,r,ch,y,x,state,curx;
integer yextra # coordinate for case 5 labels;
procedure clearstate # Outputs bit codes that have accumulated;
begin comment This procedure is used in the routine that puts out the raster.
If state = n > 0, we output the code for n grey cells
(where P=1 cell, Q=2, R=4, etc.), while if state = -m < 0 we output
the code for m blanks;
if state>0 then
begin integer pt # power of 2;
string chr # corresponding character;
chr←"U"; pt←32 # the font has only "P", "Q", "R", "S", "T", and "U";
loop begin while state≥pt do
begin out(ch,chr); state←state-pt; curx←curx+pt;
end;
if state=0 then return;
pt←pt lsh -1; chr←chr-1;
end;
end;
curx←curx-state;
movetocol(curx);
state←0;
end;
xl←xleft*bitsperwd+(xrastmin+xpenmin) # leftmost bit position being output;
xr←xright*bitsperwd+(xrastmin+xpenmin+bitsperwd-1) # rightmost;
bxptr←0 # set list of active boxes empty;
yextra←yhigh;
p←0; if points then while llink[p]>p do p←llink[p] # start at topmost leftmost point;
while p do
begin integer j # choice number for the label;
integer m # four times the length of the label;
integer x0,y0,x1,y1 # coordinates of the box;
label advancep # go here when done with $p$;
if xcoord[p]<xl or xcoord[p]>xr or ycoord[p]>yhigh or ycoord[p]<ylow
or strng[p]=0
then go to advancep # points out of range won't be shown;
m←4*length(strng[p]);
for j←1 thru 5 do
begin integer q # runs through things that shouldn't clash;
label reject # go here when case $j$ is illegal;
case j of begin
[1] begin x0←xcoord[p]-1-m; y0←ycoord[p]+1 end;
[2] begin x0←xcoord[p]-3-2*m; y0←ycoord[p]-5 end;
[3] begin x0←xcoord[p]+1; y0←ycoord[p]-5 end;
[4] begin x0←xcoord[p]-1-m; y0←ycoord[p]-11 end;
else begin x0←infty; done end
end;
x1←x0+2+2*m; y1←y0+10;
q←p # first we will check points just before $p$;
loop begin integer x,y,r # temporary storage;
integer dist # Manhattan distance;
if (r←llink[q])≤q then
if r then q←r else done
else begin q←r; while (r←rlink[q])>q do q←r;
end;
comment The above lines moved $q$ backwards one;
y←ycoord[q]; if y>y1+1 then done # no clash possible;
if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
else dist←0;
x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
x≤x0 then dist←dist+x0-x;
if dist≤1 then go to reject;
end;
q←p # next we will check points just after $p$;
loop begin integer x,y,r # temporary storage;
integer dist # Manhattan distance;
if (r←rlink[q])≤q then
if r then q←r else done
else begin q←r; while (r←llink[q])>q do q←r;
end;
comment The above lines moved $q$ forwards one;
y←ycoord[q]; if y<y0-1 then done # no clash possible;
if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
else dist←0;
x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
x≤x0 then dist←dist+x0-x;
if dist≤1 then go to reject;
end;
q←bxptr # finally we check that no overlap occurs;
while q do
begin
if yll[q]>y1 then done;
if x1≥xll[q] and x0≤xur[q] and y0≤yll[q]+10
then go to reject;
q←prevbox[q];
end;
done # all tests have been passed;
reject: # this value of $j$ didn't work;
end;
if x0=infty then
begin comment case 5;
xll[p]←(xright+1-xleft)*bitsperwd;
xur[p]←xll[p]+2*m+2;
yextra←yextra-20; yll[p]←yextra;
end
else begin comment case 1, 2, 3, or 4;
xll[p]←x0; xur[p]←x1; yll[p]←y0;
end;
q←bxptr; r←0;
while q and yll[q]<yll[p] do
begin r←q; q←prevbox[q];
end;
prevbox[p]←q; if r then prevbox[r]←p else bxptr←p;
advancep:
if (r←rlink[p])≤p then p←r
else begin p←r; while (r←llink[p])>p do p←r;
end;
end;
comment Now all points have been output, so we output the raster pattern.
White spaces are handled by "skips", but grey cells are classified into
sixteen kinds according to the presence or absence of neighbors above, right,
below, or left of a cell. An ordinary cell has all four neighbors present.
Codes "A", "B", ..., "O" are used for the cases when one or more neighbors
are absent, using a binary code. The "fig" font uses this information to put
boundary lines at the edges.
The "fig" font is designed so that character "." placed at location (x,y) indicates
a big black dot centered on cell (x,y). The digits 0...9 and lower case letters
are designed to have a width of 8 cells, and so that the character will be
approximately centered in an 11x11 rectangle whose lower left corner is (x0,y0) and
whose upper right corner is (x0+10,y0+10) if the string begins at cell (x0+2,y0+8).
In the program below it is necessary to merge three kinds of output (point labels,
point dots, and grey cells) so that the XGP server gets its instructions in order
of decreasing y coordinates;
comment First we relink the point label boxes into down-the-page order and increase
the \\{xll} and \\{yll} coordinates to account for the font offset;
q←0; while bxptr do
begin r←prevbox[bxptr]; prevbox[bxptr]←q; q←bxptr; bxptr←r;
xll[q]←xll[q]+2; yll[q]←yll[q]+8;
end;
bxptr←q;
ch←openofil(proof); out(ch,cutpage) # begin a new page of output;
out(ch,'012&'177&'003&'000&50) # insert page number and time at XGP row 50;
out(ch,'177&'001&'040&'000&100) # beginning at XGP column 100;
out(ch,'177&'006&0) # selecting font 0;
out(ch,prfheader&cvs(prfpno←prfpno+1));
if pagewarning then out(ch," "&pagewarning);
out(ch,'177&'006&1) # then select font 1;
p←0; if points then while llink[p]>p do p←llink[p] # go to the topmost leftmost point;
for y←yhigh step -1 until ylow do
begin while bxptr and yll[bxptr]≥y do
begin comment Outputting a point label;
movetorow(yll[bxptr]);
movetocol(xll[bxptr]);
out(ch,strng[bxptr]);
bxptr←prevbox[bxptr];
end;
movetorow(y);
while p and ycoord[p]≥y do
begin comment Outputting a point dot;
if ycoord[p]=y and xcoord[p]≥xl and xcoord[p]≤xr then
begin movetocol(xcoord[p]); out(ch,".");
end;
if (r←rlink[p])≤p then p←r
else begin p←r; while (r←llink[p])>p do p←r;
end;
end;
comment Now output all grey cells in row $y$;
state←0; curx←xl; movetocol(curx);
for x←xleft thru xright do
begin integer xw # position in \\{rast};
integer z # current bit pattern;
integer k # number of unscanned bits in $z$;
integer zt,zr,zb,zl # bit patterns of neighbors;
xw←x*rspan+y; var!gets!rast(z,xw) # z←rast[xw];
k←bitsperwd; if z then
begin zl←z lsh -1; zr← z lsh 1;
if x≠xleft then var!gets!rast!lsh!expr!lor!var
(zl,xw-rspan,bitsperwd-1);
# zl←(rast[xw-rspan] lsh(bitsperwd-1))lor zl;
if x≠xright then var!gets!rast!lsh!expr!lor!var
(zr,xw+rspan,1-bitsperwd);
# zr←(rast[xw+rspan] lsh(1-bitsperwd))lor zr;
if y≠yhigh then
var!gets!rast(zt,xw+1) comment zt←rast[xw+1];
else zt←0;
if y≠ylow then
var!gets!rast(zb,xw-1) comment zb←rast[xw-1];
else zb←0;
if z=-1 and zt=-1 and zr=-1 and zb=-1 and zl=-1 then
begin if state<0 then clearstate;
state←state+bitsperwd; k←z←0;
end
else begin zt←zt rot 1; zr←zr rot 2; zb←zb rot 3;
zl←zl rot 4 # now these are in convenient position;
end;
while z do
begin if z≥0 then
begin if state>0 then clearstate;
state←state-1;
end
else begin integer c; c←(zt land 1)+(zr land 2)+
(zb land 4)+(zl land 8);
if c=15 then
begin if state<0 then clearstate;
state←state+1;
end
else begin string chr; chr←'117 xor c;
if state≠0 then clearstate;
out(ch,chr); curx←curx+1;
end;
end;
z←z lsh 1; k←k-1;
zt←zt rot 1; zr←zr rot 1; zb←zb rot 1; zl←zl rot 1;
end;
end;
if k then
begin if state>0 then clearstate;
state←state-k;
end;
end;
end;
while bxptr do
begin comment Outputting any remaining point labels;
movetorow(yll[bxptr]);
movetocol(xll[bxptr]);
out(ch,strng[bxptr]);
bxptr←prevbox[bxptr];
end;
movetorow((ylow-70)min(yextra-50));
end;
ENDXGP
IFDVI
procedure makeproof; begin
print("No DVI proof mode yet.",nextline);
end;
ENDDVI
comment Routines for chr mode.
In this mode we output the characters in asterisk-dot form. Exactly two
columns have more than one dot, these columns specifying the pixels to the
left and right of the character (columns -1 and chardw).
Exactly one row has more than two dots, this row being the baseline (row 0);
procedure makechr # outputs the current character to .chr file;
begin integer xrk,xl,xr,xw,y,yl,yh,z,lz,xlb,lkd,rkd,bsd,ch,xwr,x,bits,xx;
label nonblank1,nonblank2,nonblank3,nonblank4;
if chardw<0 then
begin chardw←0; error("Negative chardw, replaced by 0");
end
else if chardw>xrastmax+xpenmax then overflow(xrastmax+xpenmax);
xrk←rcol(chardw);
xl←xleft min rcol(-1); xr←xright max xrk;
while xl<rcol(-1) do
begin comment try to eliminate blank column at left;
xw←xl*rspan;
for y←xw+ylow thru xw+yhigh do
IFXMEM begin var!gets!rast(xtemp,y); if xtemp then go to nonblank1; end;
ELSEC if rast[y] then go to nonblank1;
ENDC
xl←xl+1;
end;
nonblank1: while xr>xrk do
begin comment try to eliminate blank column at right;
xw←xr*rspan;
for y←xw+ylow thru xw+yhigh do
IFXMEM begin var!gets!rast(xtemp,y); if xtemp then go to nonblank2; end;
ELSEC if rast[y] then go to nonblank2;
ENDC
xr←xr-1;
end;
nonblank2: yl←ylow min 0; yh←yhigh max 0;
while yl<0 do
begin comment try to eliminate blank row at bottom;
for xw←xleft*rspan+yl step rspan until xright*rspan+yl do
IFXMEM begin var!gets!rast(xtemp,xw); if xtemp then go to nonblank3; end;
ELSEC if rast[xw] then go to nonblank3;
ENDC
yl←yl+1;
end;
nonblank3: while yh>0 do
begin comment try to eliminate blank row at top;
for xw←xleft*rspan+yh step rspan until xright*rspan+yh do
IFXMEM begin var!gets!rast(xtemp,xw); if xtemp then go to nonblank4; end;
ELSEC if rast[xw] then go to nonblank4;
ENDC
yh←yh-1;
end;
nonblank4:if xl=rcol(-1) then z←1 lsh (hw+1) else z←0; xw←xl*rspan;
for y←xw+ylow thru xw+yhigh do var!gets!rast!lor!var(z,y) # z←z lor rast[y];
lz←0; while z>0 do
begin lz←lz+1; z←z lsh 1;
end;
xlb←1-hw+lz+bitsperwd*(xl-rcol(0));
ch←openofil(chrs);
out(ch,'14&"'"&cvos(charcode)&nextline);
y←yh; lkd←rkd←bsd←0;
while y≥yl or lkd≤1 or rkd≤1 do
begin label rowdone;
xw←xl*rspan+y; xwr←xr*rspan+y;
x←xlb; var!gets!rast!lsh!expr(z,xw,lz) # z←rast[xw] lsh lz;
bits←bitsperwd-lz;
loop begin if bits=0 then
begin bits←bitsperwd; xw←xw+rspan;
var!gets!rast(z,xw) # z←rast[xw];
end;
if z<0 then out(ch,"*")
else if x=-1 then
begin out(ch,"."); lkd←lkd+1;
end
else if x=chardw then
begin out(ch,"."); rkd←rkd+1;
end
else if y=0 then
begin label nonblank;
if z=0 and x>chardw and bsd>2 then
begin for xx←xw+rspan step rspan until xwr do
IFXMEM begin var!gets!rast(xtemp,xx);
if xtemp then go to nonblank; end;
ELSEC if rast[xx] then go to nonblank;
ENDC
go to rowdone;
end;
nonblank: out(ch,"."); bsd←bsd+1;
end
else begin label nonblank;
if z=0 and x>chardw then
begin for xx←xw+rspan step rspan until xwr do
IFXMEM begin var!gets!rast(xtemp,xx);
if xtemp then go to nonblank; end;
ELSEC if rast[xx] then go to nonblank;
ENDC
go to rowdone;
end;
nonblank: out(ch," ");
end;
z←z lsh 1; bits←bits-1; x←x+1;
end;
rowdone: out(ch,nextline); y←y-1;
end;
end;
comment Routines for fnt mode.
In this mode we output the characters in binary format as required by the
XGP conventions documented in "Find a Font" by Les Earnest,
SAIL Operating Note 74, May 1976, as subsequently modified to allow negative
left kerns and to pack data according to raster_width instead of character_width;
define ytop=⊂fntdir['203]⊃, maxwdth=⊂fntdir['202]⊃, maxdpth=⊂fntdir['201]⊃;
procedure makefnt # outputs the current character to .fnt file;
begin integer xl,xr,z,xw,y,lz,xlb,xrb,lzr,yl,yh,ch,xlw,lz1,xrw;
integer rasterwidth,datarowcount,rowsfromtop,leftkern,wordcount;
label nonblank3,nonblank4,outchar;
ch←openofil(xgpfnt);
if chardw<0 then
begin chardw←0; error("Negative chardw, replaced by 0");
end;
xl←xleft; xr←xright; z←0;
loop begin comment try to eliminate blank column at left;
xw←xl*rspan;
for y←xw+ylow thru xw+yhigh do
var!gets!rast!lor!var(z,y) # z←z lor rast[y];
if z then done;
xl←xl+1;
if xl>xr then
begin comment blank raster;
rasterwidth←rowsfromtop←datarowcount←leftkern←wordcount←0;
go to outchar;
end;
end;
lz←0; while z>0 do
begin lz←lz+1; z←z lsh 1;
end;
xlb←(1-hw-bitsperwd*rcol(0))+lz+bitsperwd*xl;
z←0;
loop begin comment try to eliminate blank column at right. The
loop is guaranteed to halt, since raster is non-empty;
xw←xr*rspan;
for y←xw+ylow thru xw+yhigh do
var!gets!rast!lor!var(z,y) # z←z lor rast[y];
if z then done;
xr←xr-1;
end;
comment Assert z≠0;
lzr←rightmostbitindex(z);
xrb←(1-hw-bitsperwd*rcol(0))+lzr+bitsperwd*xr;
yl←ylow; yh←yhigh;
loop begin comment try to eliminate blank row at bottom;
for xw←xl*rspan+yl step rspan until xr*rspan+yl do
IFXMEM begin var!gets!rast(xtemp,xw); if xtemp then go to nonblank3; end;
ELSEC if rast[xw] then go to nonblank3;
ENDC
yl←yl+1;
end;
nonblank3:
loop begin comment try to eliminate blank row at top;
for xw←xl*rspan+yh step rspan until xr*rspan+yh do
IFXMEM begin var!gets!rast(xtemp,xw); if xtemp then go to nonblank4; end;
ELSEC if rast[xw] then go to nonblank4;
ENDC
yh←yh-1;
end;
nonblank4: if yh>ytop then
begin error("Character '"&cvos(charcode)&" goes over the top ("&
cvs(yh)&" > "&cvs(ytop)&")");
yh←ytop;
end;
if chardw<xlb then
begin lz←(chardw+(hw-1)) mod bitsperwd; xlb←chardw; xl←rcol(chardw);
end;
maxwdth←maxwdth max chardw;
maxdpth←maxdpth min yl;
rasterwidth←xrb-xlb+1;
datarowcount←yh-yl+1;
wordcount←if rasterwidth>hw then ((rasterwidth-1) div bitsperwd + 1)*datarowcount
else (datarowcount-1) div (bitsperwd div rasterwidth) + 1;
leftkern←-xlb;
rowsfromtop←ytop-yh;
outchar:
if fntdir[charcode] then error("Duplicate charcode: '"&cvos(charcode));
fntdir[charcode]←(chardw lsh hw)+fntptr;
comment The next two lines assume that bitsperwd=36;
wordout(ch,(rasterwidth lsh 27)+(charcode lsh 18)+wordcount+2);
wordout(ch,(leftkern lsh 27)+(rowsfromtop lsh 18)+datarowcount);
fntptr←fntptr+2+wordcount;
if rasterwidth=0 then return;
xlw←xl*rspan; lz1←lz-bitsperwd;
if rasterwidth≤hw then
begin integer bits,accum;
bits←accum←0;
for y←xlw+yh step -1 until xlw+yl do
begin var!gets!two!rast!cols(z,y,lz)
# z←(rast[y] lsh lz)+(rast[y+rspan] lsh lz1);
accum ← accum lor (z lsh (-bits));
bits←bits+rasterwidth;
if bits+rasterwidth>bitsperwd then
begin wordout(ch,accum);
bits←accum←0;
end;
end;
if bits then wordout(ch,accum);
end
else begin xrw←xr*rspan; if lz>lzr then xrw←xrw-rspan;
for y←yh step -1 until yl do for xw←y+xlw step rspan until y+xrw do
IFXMEM begin var!gets!two!rast!cols(xtemp,xw,lz);
wordout(ch,xtemp); end;
ELSEC wordout(ch,(rast[xw]lsh lz)+(rast[xw+rspan]lsh lz1));
ENDC
end;
end;
comment Routines for .oc files and .wd files;
IFDOVERMODES require "MFDOVR.SAI" source_file; ENDDOVERMODES
comment Routines for tfm mode.
This mode is a rather tedious set of routines that pack information into the
format TEX wants;
integer nwd,nht,ndp,nic,nvc;
internal integer nkr,nlg # table pointers in tfm mode;
internal saf integer array tfmdir[0:'177] # tfm mode character table;
internaldef wds=8,hts=4,dps=4,ics=6,tgs=2,rems=8 # sizes of tfm fields;
define wdmsk=(1 lsh wds)-1,htmsk=(1 lsh hts)-1,dpmsk=(1 lsh dps)-1,
icmsk=(1 lsh ics)-1, vcmsk=(1 lsh rems)-1;
define wdd=remd+rems+tgs+ics+dps+hts;
internaldef lgmsk=(1 lsh rems)-1 # maximum ligature field;
internaldef remd=0 # ligature displacement;
internaldef tgmsk=(1 lsh tgs)-1;
internaldef tgd=remd+rems # tag field is just to the left of rem field;
internaldef tagnone=0, taglig=1, taglist=2, tagvar=3;
saf real array tfmwd[0:wdmsk+1] # tfm width table;
saf real array tfmht[0:htmsk+1] # tfm height table;
saf real array tfmdp[0:dpmsk+1] # tfm depth table;
saf real array tfmic[0:icmsk+1] # tfm italic-correction table;
internal boolean isvarchar # this is a built-up character;
internal integer varchardata # the four charcodes of the pieces;
saf integer array tfmvc[0:vcmsk] # tfm varchar table;
internal saf integer array tfmlg[0:lgmsk] # tfm ligature-and-kern codes;
internal saf real array tfmkr[0:lgmsk] # tfm kern values;
internaldef tfmparsize=24 # max number of tfm parameters;
internal saf real array tfmpars[1:tfmparsize] # tfm parameters;
internal integer tfmptr # number of tfm parameters stored;
preload_with true; saf boolean array tfmnot[0:0] # tfm tables initialized;
internal procedure tfminit;
if tfmnot[0] then
begin integer i;
for i←0 thru '177 do tfmdir[i]←0; nkr←nvc←nlg←-1;
nwd←nht←ndp←nic←0; tfmwd[0]←0.0 # used to mark missing chars;
tfmic[0]←0.0 # zero ital correction is same as no ital correction;
tfmht[0]←tfmdp[0]←0.0; # so missing characters look right;
tfmptr←0;
tfmnot[0]←false;
end;
procedure maketfm # enters tfm information for current character;
begin integer jwd,jht,jdp,jic;
tfminit;
tfmwd[nwd+1]←charwd; jwd←1 # NOT 0, since zero flags a non-existent character;
while tfmwd[jwd]≠charwd do jwd←jwd+1;
if jwd>nwd then if nwd<wdmsk then nwd←jwd else
begin real diff; integer k; diff←abs(tfmwd[0]-charwd); jwd←0;
for k←1 thru wdmsk do
begin real delta; delta←abs(tfmwd[k]-charwd);
if delta<diff then
begin diff←delta; jwd←k;
end;
end;
error("Rounding of charwd necessary, "&cvf(charwd)&" → "&cvf(tfmwd[jwd]));
end;
tfmht[nht+1]←charht; jht←0; while tfmht[jht]≠charht do jht←jht+1;
if jht>nht then if nht<htmsk then nht←jht else
begin real diff; integer k; diff←abs(tfmht[0]-charht); jht←0;
for k←1 thru htmsk do
begin real delta; delta←abs(tfmht[k]-charht);
if delta<diff then
begin diff←delta; jht←k;
end;
end;
error("Rounding of charht necessary, "&cvf(charht)&"→"&cvf(tfmht[jht]));
end;
tfmdp[ndp+1]←chardp; jdp←0; while tfmdp[jdp]≠chardp do jdp←jdp+1;
if jdp>ndp then if ndp<dpmsk then ndp←jdp else
begin real diff; integer k; diff←abs(tfmdp[0]-chardp); jdp←0;
for k←1 thru dpmsk do
begin real delta; delta←abs(tfmdp[k]-chardp);
if delta<diff then
begin diff←delta; jdp←k;
end;
end;
error("Rounding of chardp necessary, "&cvf(chardp)&"→"&cvf(tfmdp[jdp]));
end;
tfmic[nic+1]←charic; jic←0; while tfmic[jic]≠charic do jic←jic+1;
if jic>nic then if nic<icmsk then nic←jic else
begin real diff; integer k; diff←abs(tfmic[0]-charic); jic←0;
for k←1 thru icmsk do
begin real delta; delta←abs(tfmic[k]-charic);
if delta<diff then
begin diff←delta; jic←k;
end;
end;
error("Rounding of charic necessary, "&cvf(charic)&"→"&cvf(tfmic[jdp]));
end;
if isvarchar then
begin case field(tg,tfmdir[charcode]) of begin
[tagnone] ;
[taglig] error("Varchar can't have ligature/kern");
[taglist] error("Varchar can't be in the middle of a charlist");
else confusion
end;
tfmdir[charcode]←tfmdir[charcode] xor ((tagnone xor tagvar) lsh tgd);
nvc←nvc+1; tfmvc[nvc]←varchardata;
tfmdir[charcode]←tfmdir[charcode] lor (nvc lsh remd);
end;
tfmdir[charcode]←(((((((jwd lsh hts)lor jht)lsh dps)lor jdp)lsh ics)lor jic)lsh (tgs+rems)) lor tfmdir[charcode];
end;
simp procedure addtochecksum(integer val);
begin
comment checksum method is to accumulate the one's complement
quantity $\sum↓i D↓i*2↑i$ where $D↓i$ is the $i$th data
word to be checked;
checksum←checksum lsh 1 # rotate;
if (checksum lsh -32) then checksum←checksum-'40000000000+1 # rotate;
checksum←checksum+(val land '37777777777) # add and then;
if (checksum lsh -32) then
checksum←checksum-'40000000000+1 # end-around-carry;
end;
simp integer procedure tfmfix(real r; boolean scaleflg);
begin
integer int;
if scaleflg then r←r/designsize;
int←r*(2↑20)+0.5;
return(int);
end;
procedure tfmout # this procedure computes the information that
constitutes the .tfm, and generates the checksum from that.
Then, if tfmmode is true, it writes out a .tfm file;
begin integer ch,i,j,c,bc,ec,nc,lh,lf,nw,nh,nd,ni,nl,nk,ne,np,bp;
for bc←0 step 1 until '177 do if field(wd,tfmdir[bc])≠0 then done;
for ec←'177 step -1 until 0 do if field(wd,tfmdir[ec])≠0 then done;
if bc>ec then begin bc←1; ec←0 end;
nc←ec-bc+1;
while tfmptr<7 do tfmpars[tfmptr←tfmptr+1]←0.0;
lh←18 # current length of header for .tfm;
nw←nwd+1; nh←nht+1; nd←ndp+1; ni←nic+1;
nl←nlg+1; nk←nkr+1; ne←nvc+1; np←tfmptr;
lf←6+lh+nc+nw+nh+nd+ni+nk+nl+ne+np;
checksum←0;
comment everything gets checked except for header data;
addtochecksum(bc lsh 16 lor ec);
addtochecksum(nw lsh 16 lor nh);
addtochecksum(nd lsh 16 lor ni);
addtochecksum(nl lsh 16 lor nk);
addtochecksum(ne lsh 16 lor np);
for c←bc thru ec do addtochecksum(tfmdir[c]);
for i←0 thru nw-1 do addtochecksum(tfmfix(tfmwd[i],true));
for i←0 thru nh-1 do addtochecksum(tfmfix(tfmht[i],true));
for i←0 thru nd-1 do addtochecksum(tfmfix(tfmdp[i],true));
for i←0 thru ni-1 do addtochecksum(tfmfix(tfmic[i],true));
for i←0 thru nl-1 do addtochecksum(tfmlg[i]);
for i←0 thru nk-1 do addtochecksum(tfmfix(tfmkr[i],true));
for i←0 thru ne-1 do addtochecksum(tfmvc[i]);
for i←1 thru np do addtochecksum(tfmfix(tfmpars[i],i≠1)) # scale
all parameters except the first, which is slant (a pure number);
comment OK, we have computed the checksum. Now, does user want
a .tfm file written?;
if not tfmmode then return;
ch←openofil(tfm);
if fontfacebyte<0 or fontfacebyte>255 then
errorstop("Font face byte out of bounds");
Wout(tfm,lf); Wout(tfm,lh);
Wout(tfm,bc); Wout(tfm,ec);
Wout(tfm,nw); Wout(tfm,nh);
Wout(tfm,nd); Wout(tfm,ni);
Wout(tfm,nl); Wout(tfm,nk);
Wout(tfm,ne); Wout(tfm,np);
comment Now output the header data;
Dout(tfm,checksum);
Dout(tfm,tfmfix(designsize,false));
BCPLout(tfm,codingscheme,40) # character coding scheme string;
BCPLout(tfm,fontidentifier,20) # PARC family name;
Dout(tfm,(2↑31)+fontfacebyte) # sevenbitsafeflag and PARC face byte;
comment Check if the last step of the lig/kern program has the stop bit set;
if (nlg≥0) and (tfmlg[nlg] lsh -31 = 0) then
begin
error("Ligature/kern program didn't end");
tfmlg[nlg]←tfmlg[nlg] lor (1 lsh 31);
end;
comment Then output the data...;
for c←bc thru ec do Dout(tfm,tfmdir[c]);
for i←0 thru nw-1 do Dout(tfm,tfmfix(tfmwd[i],true));
for i←0 thru nh-1 do Dout(tfm,tfmfix(tfmht[i],true));
for i←0 thru nd-1 do Dout(tfm,tfmfix(tfmdp[i],true));
for i←0 thru ni-1 do Dout(tfm,tfmfix(tfmic[i],true));
for i←0 thru nl-1 do Dout(tfm,tfmlg[i]);
for i←0 thru nk-1 do Dout(tfm,tfmfix(tfmkr[i],true));
for i←0 thru ne-1 do Dout(tfm,tfmvc[i]);
for i←1 thru np do Dout(tfm,tfmfix(tfmpars[i],i≠1)) # scale
all parameters except the first, which is slant (a pure number);
end;
comment Routines for Alphatype fonts;
internal integer yoffset # character to be shifted up this amount by typesetting routine;
internal integer xoffset # character to be shifted right this amount by typesetting routine;
internal integer alfch # channel being used for crsmode;
integer offptr # number of entries in offtable;
define offsize=13 # max number of entries in a reasonable offtable;
saf integer array offtable[1:offsize] # offsets used so far;
internal integer alfptr # number of words output in crsmode;
internal integer alfylow,alfyhigh,alfxleft,alfxright # rectangle to output in crsmode;
internal integer antid # identification word for ANT file;
IFC ALPHATYPEMODE THENC
internaldef maxglyph=400 # maximum number of subglyphs per font;
internal saf integer array minmax[0:maxglyph+1] # xmin,xmax,bytetimes (packed);
saf integer array xyoff[0:maxglyph] # x and y offsets;
saf integer array byteref[0:maxglyph] # number of bytes and ANT pointer;
define lowten(y)=⊂10*(((y+30000) div 10)-3000)⊃ # round down to multiple of 10;
saf integer array saveleft,saveright[lowten(yrastmin+ypenmin):
lowten(yrastmax+ypenmax)+9] # temporary storage while raster is being diddled;
ifc WAITS thenc
ifc SPECRAST thenc
require "alfbig.rel[alf,dek]" load_module; elsec
require "alfnrm.rel[alf,dek]" load_module; endc
elsec
require "ALFOUT.REL" load_module; comment clean, boundarize, crscode;
endc
ELSEC
internal procedure clean;; internal procedure boundarize;;
internal integer procedure crscode; return(0);
ENDC
recursive procedure alfout(integer x0,x1,y0,y1) # outputs sub-character in crsmode;
begin comment This procedure outputs a rectangular section of the current
character, from columns x0 to x1 inclusive and from rows y0 to y1 inclusive.
The calling procedure ensures that column x1 does not fall among the rightmost
six bits of a word;
integer x00,x10,xlb,xrb,leftmask,rightmask,k,antloc,i;
label failure;
if y1-y0>1020 or x1-x0>1978 then go to failure;
if y1<760 and y0≥-260 then yoffset←0
else begin comment We try to minimize the number of distinct offsets;
integer i; label found;
for i←1 thru offptr do if y1-offtable[i]≤760 and y0-offtable[i]≥-260 then
begin yoffset←offtable[i]; go to found;
end;
if offptr=offsize then if y1>760 then yoffset←y1-760 else yoffset←y0+260
else begin offptr←offptr+1;
yoffset←10*((y1+y0-490) div 20);
offtable[offptr]←yoffset;
end;
found:
end;
if x1≤1650 and x0≥-328 then xoffset←0
else if x1>1650 then xoffset←x1-1650 else xoffset←x0+328;
xlb←(x0-(xrastmin+xpenmin)) mod bitsperwd # position of leftmost bit;
leftmask←(-1) lsh (-xlb);
xrb←(x1-(xrastmin+xpenmin)) mod bitsperwd # position of rightmost bit, is <30;
rightmask←(-1) lsh (bitsperwd-1-xrb);
x00←rloc(x0,0); x10←rloc(x1,0);
for i←y0 thru y1 do
begin comment save raster bits, then mask out unwanted section;
var!gets!rast(saveleft[i],x00+i);
rast!gets!rast!land!expr(x00+i,leftmask);
var!gets!rast(saveright[i],x10+i);
rast!gets!rast!land!expr(x10+i,rightmask);
end;
antloc←alfptr;
alfylow←y0; alfyhigh←y1; alfxleft←rcol(x0); alfxright←rcol(x1);
clean; boundarize; k←crscode;
leftmask←lnot leftmask; rightmask←lnot rightmask;
for i←y0 thru y1 do
begin comment resotre the raster bits that were saved;
rast!gets!rast!lor!expr(x00+i,saveleft[i] land leftmask);
rast!gets!rast!lor!expr(x10+i,saveright[i] land rightmask);
end;
if k>0 then
begin comment the character was converted without a hitch;
if fntptr>maxglyph then overflow(maxglyph);
xyoff[fntptr]←(((2*xoffset div 3) land '177777) lsh 16)+
((3*yoffset div 10) land '177777);
byteref[fntptr]←(k lsh 21)+antloc;
fntptr←fntptr+1;
return;
end;
if k=0 then return # empty;
failure: comment we will bisect the rectangle and try again;
if 2*(x1-x0)≥y1-y0 and y1-y0≤1020 then
begin integer x2;
x2←3*((x0+x1) div 6);
if (x2-(xrastmin+xpenmin+1)) mod bitsperwd ≥ bitsperwd-6 then x2←x2+6;
print(nextline,"Inserting crsxbreak ",x2);
alfout(x0,x2-1,y0,y1); alfout(x2,x1,y0,y1);
end
else begin integer y2;
y2←10*((x0+x1) div 20);
print(nextline,"Inserting crsybreak ",y2);
alfout(x0,x1,y0,y2-1); alfout(x0,x1,y2,y1);
end;
end;
procedure makealf # outputs the current character to ANT file;
begin integer j,k,crsalign,xy,aftptr;
alfch←openofil(alf); crsalign←0;
if fntdir[charcode] then error("Duplicate charcode: '"&cvos(charcode));
brktab[0,0]←xleft*bitsperwd+(xrastmin+xpenmin) # leftmost relevant bit position;
brktab[0,brkptr[0]+1]←(xright*bitsperwd+(xrastmin+xpenmin+bitsperwd))
min (xpenmax+xrastmax+1) # rightmost relevant bit position, plus 1;
brktab[1,0]←lowten(ylow) # bottommost row;
brktab[1,brkptr[1]+1]←lowten(yhigh)+10 # topmost row, plus 1;
for xy←0 thru 1 do
begin j←brkptr[xy]; while j>0 do
begin if brktab[xy,j]≥brktab[xy,j+1]-32 or
brktab[xy,j]≤brktab[xy,0]+32 then
begin integer k; comment remove unnecessary break;
if brktab[xy,j]>900000 then crsalign←1 lsh 15;
k←j; while k≤brkptr[xy] do
begin brktab[xy,k]←brktab[xy,k+1]; k←k+1;
end;
brkptr[xy]←brkptr[xy]-1;
end
else if xy=0 and (brktab[0,j]-(xpenmin+xrastmin+1)) mod bitsperwd
≥ bitsperwd-6 then brktab[0,j]←brktab[0,j]+6;
j←j-1;
end;
end;
aftptr←fntptr;
for j←0 thru brkptr[0] do for k←0 thru brkptr[1] do
alfout(brktab[0,j], brktab[0,j+1]-1, brktab[1,k], brktab[1,k+1]-1);
fntdir[charcode]←((crsalign+fntptr-aftptr) lsh 16) + 256 + 5*aftptr;
fntdir[charcode+128]←tfmfix(charwd,true);
end;
internal procedure initout # get MFOUT started properly;
begin integer i # runs from 1 to numberofmodes;
maintitle←ofilname←null;
for i←1 thru numberofmodes do ochan[i]←-1;
for i←1 thru numberofmodes do bytecount[i]←0;
ofilext[tfm]←".tfm"; ofilext[xgpfnt]←".fnt";
IFPRESS ofilext[proof]←".press"; ENDPRESS
IFXGP ofilext[proof]←".xgp"; ENDXGP
ofilext[alf]←".ant"; ofilext[chrs]←".chr";
IFDOVERMODES ofilext[doveroc]←".oc"; ofilext[presswd]←".wd"; ENDDOVERMODES
IFC TENEX OR TOPS20 THENC octaltime←gtad; ENDC
IFWAITS octaltime←call(0,"ACCTIM"); ENDWAITS
timeofday←daytime;
tptr←1; llink[0]←rlink[0]←0;
offptr←0;
IFPRESS
cellsize←4; cellsh←2;
rotated←false;
IFTENEX
comment Now allocate the Press output buffers from the high segment:;
highsegalloc(dlbufptr,d0lenpages);
highsegalloc(elbufptr,e0lenpages);
highsegalloc(partdirbufptr,partdirlenpages);
ELSEC
dlbufptr←location(dlbuf[0]);
elbufptr←location(elbuf[0]);
partdirbufptr←location(partdirbuf[0]);
ENDC
ENDPRESS
end;
internal procedure charclear # initializes parameters for a new character;
begin charwd←chardp←charht←charic←charwx←charwy←0.0; isvarchar←false;
chardw←0; charcode←-1;
brkptr[0]←brkptr[1]←0; brktab[0,0]←brktab[1,0]←1 lsh (bitsperwd-1);
IFDOVERMODES bndboxvalid←false; ENDDOVERMODES
end;
internal procedure finishchar # outputs a finished character;
begin if chardisplay then ddoutrast;
if charcode≥0 and charcode<'200 then
begin if xleft=infty then
begin comment blank character;
xleft←xright←rcol(0); yhigh←ylow←0;
end;
if chrmode then makechr;
if proofmode then makeproof;
if needchecksum then maketfm;
if fntmode then makefnt;
IFDOVERMODES
if ocmode then makeoc;
if wdmode then makewd;
ENDDOVERMODES
if crsmode then
begin
makealf;
if chardisplay then ddoutrast # show rast in case it changed;
end;
clearrast;
end
else if xleft<infty then
begin if proofmode then makeproof else
error("Image lost since charcode not specified");
clearrast;
end;
llink[0]←0; tptr←1 # clear the symbol table;
end;
IFC TOPS20 OR TENEX THENC
procedure binaryrelease(integer chan);
begin comment Make TENEX realize that file is 8-bit bytes;
integer fllen # file length;
integer array fdb[0:'24] # file descriptor block;
closf(chan);
gtfdb(chan, fdb);
fllen←fdb['12];
comment change byte size from 36 to 8;
chfdb(chan, '11, (2↑6-1) lsh 24, 8 lsh 24);
comment and multiply EOF byte count by 4 to compensate;
chfdb(chan, '12, -1, 4*fllen);
rljfn(chan);
end;
ENDC
IFWAITS
procedure binaryrelease(integer chan);
release(chan);
ENDWAITS
internal procedure closeout # finishes off the output;
begin
if needchecksum then tfmout;
if ochan[tfm]≥0 then
begin
binaryrelease(ochan[tfm]);
print(nextline,"TEX font metrics written on ",flname[tfm]);
end;
if ochan[chrs]≥0 then
begin release(ochan[chrs]);
print(nextline,"Characters for editing written on file ",flname[chrs]);
end;
if ochan[alf]≥0 then
begin integer i;
for i←0 thru '377 do out32(alfch,fntdir[i]);
IFC ALPHATYPEMODE THENC
for i←0 thru fntptr-1 do
begin out32(alfch,xyoff[i]); out32(alfch,minmax[i]);
out32(alfch,byteref[i]); out32(alfch,0); out32(alfch,0);
end;
ENDC
out32(alfch,checksum);
i←magnification*1000+.5;
out32(alfch,i);
out32(alfch,(1365 lsh 16)+2047);
out32(alfch,tfmfix(designsize,false));
out32(alfch,alfptr);
binaryrelease(alfch);
print(nextline,"Images written on ",flname[alf]);
end;
if ochan[xgpfnt]≥0 then
begin useto(ochan[xgpfnt],1) # reposition font file at its beginning;
fntdir['203]←fntdir['203]+1 # this seems to work;
fntdir['201]←fntdir['203]-fntdir['201] # max(rowsfromtop+datarowcount);
arryout(ochan[xgpfnt],fntdir[0],'400) # write the font directory;
binaryrelease(ochan[xgpfnt]);
print(nextline,"Images written on ",flname[xgpfnt]);
end;
IFDOVERMODES
if ochan[doveroc]≥0 then
begin occloseout;
binaryrelease(ochan[doveroc]);
print(nextline,"Images written on ",flname[doveroc]);
end;
if ochan[presswd]≥0 then
begin wdcloseout;
binaryrelease(ochan[presswd]);
print(nextline,"PrePress-style widths written on ",flname[presswd]);
end;
ENDDOVERMODES
if ochan[proof]≥0 then
begin
IFPRESS proofcloseout; binaryrelease(ochan[proof]); ENDPRESS
IFXGP release(ochan[proof]); ENDXGP
print(nextline,"Proof figures written on file ",flname[proof]);
IFWAITS ptostr(0,
IFXGP "r xgpsyn;"&flname[proof]&"/L" ENDXGP
IFPRESS "dover "&flname[proof] ENDPRESS
);
ENDWAITS
end;
end;
comment Stuff for extended memory;
IFXMEM
define bigsmap=false; comment only true when DEC fixes process smaping;
internal integer indir # addressing '@INDIR' gets the raster item whose
number is in register '15;
internal integer xtemp # used with VAR!GETS!RAST when there's no place
else to put it;
internal integer xblte # extended-blt instruction;
define fhslf='400000, pmrd='100000, pmwr='40000, pmcnt='400000,
smap='767, pmap='56, rpcap='150, epcap='151;
procedure makesect(integer s); begin
start!code
movei 1,0;
movsi 2,fhslf;
add 2,s; comment make new section;
movsi 3,pmrd+pmwr+pmcnt;
hrri 3,1; comment number of sections to be made;
jsys smap;
end;
end;
procedure delsect(integer s); begin
start!code
movni 1,1;
movsi 2,fhslf;
add 2,s; comment delete section;
movsi 3,pmrd+pmwr+pmcnt;
hrri 3,1; comment number of sections to be deleted;
jsys smap;
end;
end;
procedure makesectone; begin
if bigsmap then begin
start!code comment smap section 0 to section 1;
movsi 1,fhslf;
move 2,1;
hrri 2,1; comment make section 1;
movsi 3,pmrd+pmwr;
hrri 3,1; comment one section to be mapped;
jsys smap;
end;
end
else begin comment only smap with 0 in acc 1, never fhslf;
makesect(1);
start!code comment pmap pages 0-777 to 1000-1777;
movsi 1,fhslf;
move 2,1;
hrri 2,'1000;
movsi 3,pmrd+pmwr+pmcnt;
hrri 3,'1000;
jsys pmap;
end
end
end;
procedure delsectone; begin
if bigsmap then delsect(1)
else begin
start!code comment unmap pages 1000-1777;
movni 1,1;
movsi 2,fhslf;
hrri 2,'1000;
movsi 3,pmcnt;
hrri 3,'1000;
jsys pmap;
end;
delsect(1);
end
end;
integer numsections # number of 256Kword sections to use for raster;
forward simple procedure cntrlc # the control-c handler;
integer array cntrlcmess[0:30] # can't use strings during interrupts;
integer array continuemess[0:30] # can't use strings during interrupts;
internal procedure initxmem; begin integer i; string s;
start!code comment test for recently fixed sail bug;
movei 1,2;
move 2,access(1); comment specifically, this move should not
compile into MOVE 2,1;
movem 2,xtemp;
end;
if xtemp neq 1 then
errorstop("Your SAIL compiler isn't up to date enough.");
start!code comment Enable control-c interrupt handler;
movei 1,fhslf;
jsys rpcap;
movsi 7,'400000;
ior 3,7;
jsys epcap;
end;
psimap(1,cntrlc,0,1); enable(1); ati(1,3);
s←"
You are control-c'ing out of Metafont. Do you want to be able to continue? ";
i←-1;while s do begin cntrlcmess[i←i+1]←cvasc(s); s←s[6 to inf]; end;
s←"Metafont continuing... ";
i←-1;while s do begin continuemess[i←i+1]←cvasc(s); s←s[6 to inf]; end;
xblte←'020000000000;
indir←('150002 lsh 18) - rast0 # so @INDIR addresses RAST[R'15];
numsections←((rast1-rast0) lsh -18) + 1;
makesectone;
for i←2 step 1 until numsections+1 do makesect(i);
end;
internal procedure closexmem; begin integer i;
delsectone;
for i←2 step 1 until numsections+1 do delsect(i);
end;
simple procedure cntrlc; begin integer answer;
start!code movei 1,cntrlcmess[0]; psout; pbin; movem 1,answer; end;
if answer="y" or answer="Y" then begin
quick!code haltf end;
start!code movei 1,continuemess[0]; psout; end;
end
else begin integer i; label foo;
delsectone; for i←2 step 1 until numsections+1 do delsect(i);
foo: quick!code haltf end;
print("Can't continue this Metafont anymore."); go to foo; end;
end;
ENDXMEM
end